//	COPYRIGHT (C) 1981 BY BOARD OF TRUSTEES,
//	LELAND STANFORD JUNIOR UNIVERSITY

$LIBRARY "BCPLIB.REL[1,202]"
$NOLIST
GET "BCPLIB.GET"
GET "MYLIB.GET"

// LET SC3FILENAME() = VALOF 
// $( STATIC $( FNAME = 0; V1 = VEC 6; V2 = VEC 6 $);
// IF FNAME=0 DO FNAME:=PACKSTRING(ADD3DIG(UNPACKSTRING("000SC3",V1),JOBNO()),V2);
// RESULTIS FNAME
//  $);


let INOCT() = valof $(in8
  static $( res = nil; ch = nil $);
  res:=0;
  ch:=INCH() repeatuntil ((ch GE '0') & (ch LE '7'));
  while (ch GE '0') & (ch LS '8') do $(rd
   res:=(res << 3) + (ch - '0');
   ch:=INCH()
   $)rd
  resultis res
  $)in8;


EXTERNAL $( DRAW $)

static $( VECSPACE = vec 40000; STACK = vec 6500; STACKPTR = 0 $);
let DOSTUFF() be
$( static $( NSPACE=NIL; NTYPES=NIL; TYPENAME=NIL; TYPEVALENCE=NIL; ATTYPE=NIL;
             HMIN=NIL; NNODES=NIL; U=NIL; GSTART=1; GSTOP=NIL;
             TYPENUM = NIL; PATSTART=NIL; PATSTOP=NIL; CTABLE=NIL;
             CTSTART=NIL; CTSTOP=NIL; HMAX = NIL; NUMHS = NIL;
             DOTS = NIL; MAPPEDTO = NIL; NLNODES = NIL; LMINS = NIL;
             LMAXS = NIL; LNODE= NIL; PTFLAG = NIL; NUMISBS = NIL;
	     ARTYPE = NIL $);
static $( CTPTR = 1; NBR = NIL; ATI = NIL; TAG = NIL $);
static $( NSTRUCS = NIL; PATREC = NIL; INFILE = NIL; OUTFILE = NIL;
          INSOURCE = NIL; STRUCNUMBER = NIL $);
static $( NUMPAT = NIL; PATRECS = NIL; PATMINS = NIL; PATMAXS = NIL;
          PATNNDS = NIL; NPATNODES = NIL; KEEPIT = NIL $);
static $( PTRTOP = NIL $);
static $( NATH = NIL; ATHSTART = NIL; ATTYPEH = NIL $);
static $( FEATURENAMES = NIL; FCOUNTS = NIL $);
static $( OOUT = NIL; MATCH = NIL $);
manifest $( P2WDSZ = 5; R2WDSZ = 32 $);
//SET-MANIPULATION FUNCTIONS by RAY CARHART.  SETS ARE BIT PATTERNS
//CONTAINED IN VECTORS.  THERE ARE R2WDSZ BITS STORED IN EACH
//VECTOR LOCATION AND NSETWDSM1 IS ONE LESS THAN THE NUMBER OF
//WORDS NEEDED TO REPRESENT THE SET (IE, NSETWDSM1 IS COMPUTED BY
//(HIGHEST SET ELEMENT)>>P2WDSZ).  IT IS THE CALLERS RESPONSIBILITY
//TO SET NSETWDSM1, AND TO RESTORE IT to ITS OLD VALUE WHEN DONE WITH
//THE SET FUNCTIONS.
static $( NSETWDSM1 = NIL $);
      
let SETSIZE(SET) = valof
  $( static $( FOURBITSZ = table 0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4;
               PARTSET = NIL; COUNT = NIL $);
  COUNT:=0;
  for SETI=SET to SET+NSETWDSM1 DO
    $(
    PARTSET:=!SETI;
    until PARTSET=0 DO
     $(
     COUNT+:=FOURBITSZ![PARTSET BITAND #17];
     PARTSET:=PARTSET>>4
     $)
    $);
   resultis COUNT
 $);
      
let NTHELEM(N,SET) = valof
  test SETSIZE(SET)<N then resultis PLUSINF
  or
  $( static $( ELEM = NIL; PARTSET = NIL; NEL = NIL;
               ETOP = 1<<[R2WDSZ-1] $);
   if N=0 do resultis -1;
   ELEM:=1;
   PARTSET:=!SET;
   NEL:=0;
   $(
    if [PARTSET BITAND ELEM] NE 0 do test N>1 then N-:=1 or resultis NEL;
    NEL+:=1;
    test ELEM=ETOP then $( SET+:=1; PARTSET:=!SET; ELEM:=1 $)
    or ELEM:=ELEM<<1;
   $) repeat
 $);
      
let LOWELEM(SET) = valof
 $( static $( RIGHTBIT = table 0,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0;
              ELEM = NIL; PARTSET = NIL $);
  ELEM:=0;
  for SETI=SET to SET+NSETWDSM1 DO
   test !SETI=0 then ELEM+:=R2WDSZ
   or
    $(
    PARTSET:=!SETI;
    $(
      test [PARTSET BITAND #17]=0 then ELEM+:=4
      or resultis ELEM+RIGHTBIT![PARTSET BITAND #17];
      PARTSET:=PARTSET>>4
     $) repeat
    $);
   resultis -1
 $);
      
let MAKESET() = NEWVEC(NSETWDSM1);
      
let FREESET(SET) be FREEVEC(SET);
      
let FLIPELEM(ELEM,SET) = valof
   $(
   SET![ELEM>>P2WDSZ]NEQV:=1<<[ELEM NEQV [[ELEM>>P2WDSZ]<<P2WDSZ]];
   resultis SET
  $);
      
let TESTELEM(ELEM,SET) =
   0 NE [SET![ELEM>>P2WDSZ] BITAND
       [1<<[ELEM NEQV [[ELEM>>P2WDSZ]<<P2WDSZ]]]];
      
let PUTELEM(ELEM,SET) =
   (TESTELEM(ELEM,SET) -> SET,FLIPELEM(ELEM,SET));
     
let REMELEM(ELEM,SET) =
   (TESTELEM(ELEM,SET) -> FLIPELEM(ELEM,SET),SET);
      
let DUNION(SETA,SETB) = valof
   $(
   for I=0 to NSETWDSM1 do SETA!I BITOR:=SETB!I;
   resultis SETA
 $);
      
let DUNDISJ(SETA,SETB) = valof
   $(
   for I=0 to NSETWDSM1 do SETA!I NEQV :=SETB!I;
   resultis SETA
  $);
      
let DINTERSECT(SETA,SETB) = valof
  $(
 for I=0 to NSETWDSM1 do SETA!I BITAND :=SETB!I;
 resultis SETA
$);
      
let UNION(USET,SETA,SETB) = valof
  $(
  for I=0 to NSETWDSM1 do USET!I:=SETA!I BITOR SETB!I;
  resultis USET
$);
      
let UNIONDISJ(USET,SETA,SETB) = valof
   $(
   for I=0 to NSETWDSM1 do USET!I:=SETA!I NEQV SETB!I;
   resultis USET
  $);
      
let INTERSECT(ISET,SETA,SETB) = valof
   $(
   for I=0 to NSETWDSM1 do ISET!I:=SETA!I BITAND SETB!I;
   resultis ISET
   $);
      
let INTERSECTP(SETA,SETB) = valof
  $(
  for I=0 to NSETWDSM1 DO
      if NOT (0 = (SETA!I BITAND SETB!I)) then resultis TRUE;
  resultis FALSE
  $)

let SUBSETP(LSET,SSET) = valof
  $(
  for I=0 to NSETWDSM1 DO
   if NOT (0 = (SSET!I BITAND NOT (LSET!I))) then resultis FALSE;
  resultis TRUE
  $)

let COPYSET(CSET,SET) = valof
   $(
   for I=0 to NSETWDSM1 do CSET!I:=SET!I;
   resultis CSET
   $);
      
let COPYNSET(CSET,SET) = valof
  $(
  for I=0 to NSETWDSM1 do CSET!I:= NOT (SET!I);
  resultis CSET
  $);

let OUTSET(SET) be $(
   for SETI=SET to SET+NSETWDSM1 do $( OUTOCT(!SETI); SPACES(1) $)
   $);

let INSET(SET) be $(
   for SETI=SET to SET+NSETWDSM1 do !SETI:=INOCT()
   $);

let ZEROSET(SET) =valof
    $(
    for SETI=SET to SET+NSETWDSM1 do !SETI:=0;
    resultis SET
   $);
      
let BTZ(SET) = valof
   $(
  for SETI=SET to SET+NSETWDSM1 do if !SETI NE 0 then resultis FALSE;
  resultis TRUE
  $);

manifest $( NUMTYPE = 1; STRTYPE = 2; LPARTYPE = 3; RPARTYPE = 4;
            EOLTYPE = 5; PSEOLTYPE = 6; QTYPE = 7; PSEUDOEOL = ';' $);
static $( TYPESIZE = TABLE 0,2,2,1,1,1,1,1,1; TYPEDESCR = TABLE 0,
          "A NUMBER","A WORD","A LEFT PARENTHESIS","A RIGHT PARENTHESIS",
          "A CARRIAGE-RETURN","A QUESTION MARK","A SEMICOLON" $);
static $( STV = TABLE 1,STRTYPE; NTV = TABLE 1,NUMTYPE;
          NSTV = TABLE 2,NUMTYPE,STRTYPE; SLTV = TABLE 2,LPARTYPE,STRTYPE;
          SRTV = TABLE 2,RPARTYPE,STRTYPE $);
manifest $( LPOSNMAX = 100; ITEMCHMAX = 24 $);
static $( STRCAT = NIL; SCLEFT = NIL; STRSPAC = NIL; SSLEFT = NIL $);
static $( LITEMS = vec LPOSNMAX; LPOSN = 0;  ISSUEDPROMPT = NIL $);

let SPACEFULL(STR) be
 $(
 OUTS("SORRY, I'LL HAVE TO STOP; I'VE RUN OUT OF ");
 OUTS(STR);
 OUTS(" SPACE.*C*L");
 EXECUTERETURN()
 $);

let SPACEALMOSTFULL(STR) be
 $(
 OUTS("NOTE:  I'M ALMOST OUT OF ");
 OUTS(STR);
 OUTS(" SPACE.*C*L")
 $);

let MAKESCAT(CAT,CATSZ,SPAC,SPACSZ) be
 $(
 STRCAT:=CAT
 STRCAT!0:=0;
 SCLEFT:=CATSZ;
 STRSPAC:=SPAC;
 STRSPAC!0:=1;
 SSLEFT:=SPACSZ
 $);

let NSWORDS(STR) = 1+[!STR>>29]/5;

let NUMOFSTR(STR) = valof
 $( static $( CATIX = NIL; I = NIL; NSW = NIL; FFREE = NIL $);
 static $( SCWARN = FALSE; SSWARN = FALSE $);
 CATIX:=STRCAT!0;
 I:=0;
 while I<CATIX do $( I+:=1; if STREQUAL(STR,STRCAT!I) do resultis I $)
 if SCLEFT=0 do resultis SPACEFULL("STRING-CATALOG");
 NSW:=NSWORDS(STR);
 if NSW>SSLEFT do resultis SPACEFULL("STRING");
 FFREE:=STRSPAC+STRSPAC!0;
 BLT(STR,FFREE,FFREE+NSW-1);
 STR:=FFREE;
 STRSPAC!0+:=NSW;
 SSLEFT-:=NSW
 CATIX+:=1;
 SCLEFT-:=1;
 STRCAT!CATIX:=STR;
 STRCAT!0:=CATIX;
 if SCLEFT<10 DO
  unless SCWARN DO
   $( SPACEALMOSTFULL("STRING-CATALOG"); SCWARN:=TRUE $);
 if SSLEFT<10 DO
  unless SSWARN DO
   $( SPACEALMOSTFULL("STRING-CATALOG"); SSWARN:=TRUE $);
 resultis CATIX
 $);

let STROFNUM(N) = ([0<N LE STRCAT!0] -> STRCAT!N,"");

let OUTSNUM(STRNUM) be OUTS(STROFNUM(STRNUM));

let PUTITEM(ITEMTYPE,ITEM2,ITEM3,ITEM4,ITEM5,ITEM6) = valof
 $( static $( LPT = NIL $);
 LPT:=LPOSN+TYPESIZE!ITEMTYPE;
 if LPT>LPOSNMAX DO
  unless ITEMTYPE=EOLTYPE DO
   $(
   OUTS("LINE TOO LONG; SOME INPORMATION WAS LOST AT THE END*C*L");
   while INCH() NE '*L' DO;
   ITEMTYPE:=EOLTYPE;
   LPT:=LPOSN+1
   $);
 LPOSN:=LPT;
 SWITCHON TYPESIZE!ITEMTYPE INTO
  $(
  CASE 6: LPT-:=1; LITEMS!LPT:=ITEM6;
  CASE 5: LPT-:=1; LITEMS!LPT:=ITEM5;
  CASE 4: LPT-:=1; LITEMS!LPT:=ITEM4;
  CASE 3: LPT-:=1; LITEMS!LPT:=ITEM3;
  CASE 2: LPT-:=1; LITEMS!LPT:=ITEM2;
  CASE 1: LPT-:=1; LITEMS!LPT:=ITEMTYPE
  $);
 resultis ITEMTYPE NE EOLTYPE
 $);

let LINEIN(PROMPT) = valof
 $( static $( NEXTCHAR = NIL; ITEMCOUNT = NIL $);

 let GETCH() = valof
  $(
  NEXTCHAR:=INCH();
  if 'a' LE NEXTCHAR LE 'z' do NEXTCHAR+:=-'a'+'A';
  if NEXTCHAR='*C' do NEXTCHAR:=INCH();
  resultis NEXTCHAR
  $);

 let PACKNUMBER(V) = valof
  $( static $( ANS = NIL; NDIGITS = NIL; SIGN = NIL $);
  SIGN:=1;
  NDIGITS:=!V;
  V+:=1;
  SWITCHON !V INTO
   $(
   CASE '-': SIGN:=-1;
   CASE '+': NDIGITS-:=1; V+:=1
   $);
  ANS:=!V-'0';
  while NDIGITS>1 DO
   $(
   NDIGITS-:=1;
   V+:=1;
   ANS:=ANS*10+!V-'0'
   $);
  resultis SIGN*ANS
  $);

 let ITEMREAD() = valof
  $( static $( NUMFLAG = NIL; LINE = vec ITEMCHMAX; STR = vec [ITEMCHMAX+1]/5;
               CHCOUNT = NIL; COMMAFLAG = NIL $);
  COMMAFLAG:=FALSE;
  CHLP:
  SWITCHON NEXTCHAR INTO
   $(
   CASE ' ': GETCH(); goto CHLP;
   CASE ',': COMMAFLAG:=TRUE; GETCH(); goto CHLP;
   CASE '*L':
    test COMMAFLAG then $( OUTS("..."); COMMAFLAG:=FALSE; GETCH(); goto CHLP $)
    or resultis PUTITEM(EOLTYPE);
   CASE '(': GETCH(); resultis PUTITEM(LPARTYPE);
   CASE ')': GETCH(); resultis PUTITEM(RPARTYPE);
   CASE '?': GETCH(); resultis PUTITEM(QTYPE);
   CASE PSEUDOEOL: GETCH(); resultis PUTITEM(PSEOLTYPE);
   CASE '-': CASE '+': CASE '0'...'9': NUMFLAG:=TRUE; ENDCASE;
   DEFAULT: NUMFLAG:=FALSE
   $);
  CHCOUNT:=0;
  CHLP2:
  if CHCOUNT LE ITEMCHMAX do $( CHCOUNT+:=1; LINE!CHCOUNT:=NEXTCHAR $);
  SWITCHON GETCH() INTO
   $(
   CASE ',': CASE ' ': CASE '(': CASE ')': CASE '*L': CASE '?': CASE PSEUDOEOL:
    LINE!0:=CHCOUNT;
    test NUMFLAG BITAND [[CHCOUNT>1] BITOR ['-' NE LINE!1 NE '+']]
    then resultis PUTITEM(NUMTYPE,PACKNUMBER(LINE))
    or resultis PUTITEM(STRTYPE,NUMOFSTR(PACKSTRING(LINE,STR)));
   CASE '0'...'9': goto CHLP2;
   DEFAULT: NUMFLAG:=FALSE; goto CHLP2
   $)
  $);

 OUTS(PROMPT);
 LPOSN:=1;
 ITEMCOUNT:=0;
 GETCH();
 ITEMCOUNT+:=1 REPEATWHILE ITEMREAD();
 LITEMS!0:=ITEMCOUNT;
 LPOSN:=1;
 resultis LITEMS
 $);

let NEXTIS(ITEMTYPE) = valof
 $(
 if LPOSN=0 do $( LPOSN:=1; LITEMS!1:=EOLTYPE $);
 resultis LITEMS!LPOSN=ITEMTYPE
 $);

let LINEOUT() be
 $(

 let ITEMOUT(PREVSPACE,LPOSN) be
  $(
  SWITCHON LITEMS!LPOSN INTO
   $(
   CASE EOLTYPE: NEWLINE(1); RETURN;
   CASE PSEOLTYPE: OUTCH(PSEUDOEOL); ITEMOUT(TRUE,LPOSN+1); RETURN;
   CASE RPARTYPE: OUTCH(')'); ITEMOUT(TRUE,LPOSN+1); RETURN;
   CASE LPARTYPE:
    if PREVSPACE do SPACES(1);
    OUTCH('(');
    ITEMOUT(FALSE,LPOSN+1);
    RETURN;
   CASE QTYPE:
    if PREVSPACE do SPACES(1);
    test LITEMS![LPOSN+1]=QTYPE then
     $(
     OUTS("??");
     while LITEMS!LPOSN=QTYPE do LPOSN+:=1;
     ITEMOUT(TRUE,LPOSN);
     RETURN
     $)
    or $( OUTCH('?'); ITEMOUT(TRUE,LPOSN+1); RETURN $);
   CASE NUMTYPE:
    if PREVSPACE do SPACES(1);
    OUTNO(LITEMS![LPOSN+1]);
    ITEMOUT(TRUE,LPOSN+2);
    RETURN;
   CASE STRTYPE:
    if PREVSPACE do SPACES(1);
    OUTSNUM(LITEMS![LPOSN+1]);
    ITEMOUT(TRUE,LPOSN+2);
    RETURN
   $)
  $)

 ITEMOUT(FALSE,LPOSN)
 $);

let LOPITEM() = valof
 $(
 ISSUEDPROMPT:=FALSE;
 LPOSN+:=TYPESIZE![LITEMS!LPOSN];
 resultis LITEMS![LPOSN-1]
 $);

let FLUSHLINE() be
 $( static $( OLPOSN = NIL; TELLUSER = NIL $);
 if NEXTIS(EOLTYPE) do RETURN;
 TELLUSER:=NOT ISSUEDPROMPT;
 OLPOSN:=LPOSN;
 LOPITEM();
 unless LITEMS!LPOSN=EOLTYPE do TELLUSER:=TRUE;
 LPOSN:=OLPOSN;
 if TELLUSER DO
  $(
  OUTS("ERASING ");
  unless ISSUEDPROMPT do OUTS("...");
  LINEOUT()
  $);
 LITEMS!LPOSN:=EOLTYPE
 $);

let QRESPONSE(QSTR,QVEC,QQSTR) = valof
 $( static $( DOUBQ = NIL $);
 test NEXTIS(QTYPE) then
  $(
  DOUBQ:=FALSE;
  LPOSN+:=1;
  if NEXTIS(QTYPE) do $( DOUBQ:=TRUE; while NEXTIS(QTYPE) do LPOSN+:=1 $);
  FLUSHLINE();
  test [DOUBQ BITAND [QQSTR NE 0]] then
   $(
   OUTS(QQSTR);
   NEWLINE(1)
   $)
  OR
   $(
   if QSTR NE 0 do $( OUTS(QSTR); NEWLINE(1) $);
   if QVEC NE 0 do FOR I=1 TO QVEC!0 do $( OUTS(QVEC!I); NEWLINE(1) $)
   $)
  resultis TRUE
  $)
 or resultis FALSE
 $);

let CONDPROMPT(PROMPT,QSTR,QVEC,QQSTR,TYPEVEC) = valof
 $( static $( TYPEOK = NIL; NTYPE = NIL; OKTYPE = NIL $);
 TRYPROMPT:
 ISSUEDPROMPT:=FALSE;
 if NEXTIS(EOLTYPE) DO
  $(
  LINEIN(PROMPT);
  ISSUEDPROMPT:=TRUE;
  if NEXTIS(EOLTYPE) do resultis FALSE
  $);
 if NEXTIS(PSEOLTYPE) do $( LPOSN+:=1; resultis FALSE $);
 if QRESPONSE(QSTR,QVEC,QQSTR) do goto TRYPROMPT;
 TYPEOK:=FALSE;
 NTYPE:=TYPEVEC!0;
 while NTYPE>0 DO
  $(
  OKTYPE:=TYPEVEC!NTYPE;
  NTYPE-:=1;
  if NEXTIS(OKTYPE) do $( TYPEOK:=TRUE; BREAK $)
  $);
 if TYPEOK do resultis TRUE;
 OUTS("I WAS EXPECTING ");
 NTYPE:=TYPEVEC!0;
 while NTYPE>0 DO
  $(
  OKTYPE:=TYPEVEC!NTYPE;
  NTYPE-:=1;
  OUTS(TYPEDESCR!OKTYPE);
  test NTYPE=0 then NEWLINE(1) OR OUTS(" OR ")
  $);
 FLUSHLINE();
 goto TRYPROMPT
 $);

let STRCONTAIN(LILSTR,BIGSTR) = valof
 $( static $( NCH = NIL; CHOFF = NIL $);
 NCH:=NCHARS(LILSTR);
 CHOFF:=29;
 while NCH>0 DO
  $(
  NCH-:=1;
  CHOFF-:=7;
  if CHOFF<0 do $( LILSTR+:=1; BIGSTR+:=1; CHOFF:=29 $);
  if [#177 BITAND[!LILSTR>>CHOFF]] NE
     [#177 BITAND[!BIGSTR>>CHOFF]] do resultis FALSE
  $);
 resultis TRUE
 $);

let YESNO(PROMPT,QQSTR,DEFLT) = valof
 $( static $( RESPONSE = NIL $);
 TRYPROMPT:
 unless CONDPROMPT(PROMPT,
                   (STRCONTAIN(DEFLT,"YES") -> "YES OR NO (DEFAULT IS YES)",
                                               "YES OR NO (DEFAULT IS NO)"),
                   0,QQSTR,STV) DO
  resultis STRCONTAIN(DEFLT,"YES");
 RESPONSE:=STROFNUM(LITEMS![LPOSN+1]);
 LOPITEM();
 if STRCONTAIN(RESPONSE,"YES") do resultis TRUE;
 if STRCONTAIN(RESPONSE,"NO") do resultis FALSE;
 OUTS("I AM EXPECTING A YES OR NO ANSWER HERE*C*L");
 FLUSHLINE();
 goto TRYPROMPT
 $);

let STRSELECT(STR,SELVEC) = valof
 $( static $( NSEL = NIL; MATCHTAIL = NIL; NCSTR = NIL; AMBIG = NIL $);
 NCSTR:=NCHARS(STR);
 NSEL:=SELVEC!0;
 SELVEC+:=1;
 MATCHTAIL:=0;
 AMBIG:=FALSE;
 while NSEL>0 DO
  $(
  NSEL-:=1;
  if STRCONTAIN(STR,!SELVEC) DO
   test NCSTR=NCHARS(!SELVEC) then resultis SELVEC!1
   OR
    test MATCHTAIL=0 then MATCHTAIL:=SELVEC
    OR AMBIG:=TRUE;
  SELVEC+:=2;
  $);
 if AMBIG DO
  $(
  OUTS("I TAKE ");
  OUTS(STR);
  OUTS(" TO MEAN ");
  OUTS(!MATCHTAIL);
  NEWLINE(1);
  resultis MATCHTAIL!1
  $);
 if MATCHTAIL NE 0 do resultis MATCHTAIL!1;
 resultis !SELVEC
 $);

let PROMPTSELECT(PROMPT,QSTR,QVEC,QQSTR,POSSTRS,INSIST) = valof
 $( static $( FAILVAL = NIL; SELVAL = NIL $);
 FAILVAL:=POSSTRS![1+2*[POSSTRS!0]];
 TRYPROMPT:
 unless CONDPROMPT(PROMPT,QSTR,QVEC,QQSTR,STV) DO
   test INSIST then goto TRYPROMPT OR resultis FAILVAL;
 SELVAL:=STRSELECT(STROFNUM(LITEMS![LPOSN+1]),POSSTRS)
 if SELVAL=FAILVAL DO
  $(
  OUTSNUM(LITEMS![LPOSN+1]);
  OUTS(" IS NOT AN EXPECTED KEYWORD HERE*C*L");
  FLUSHLINE();
  goto TRYPROMPT
  $);
 LOPITEM();
 resultis SELVAL
 $);

let SWAPLITEMS() be
 $( static $( LITEMS2 = vec LPOSNMAX; LPOSN2 = 0; TEM = NIL $);
 TEM:=LITEMS;
 LITEMS:=LITEMS2;
 LITEMS2:=TEM;
 TEM:=LPOSN;
 LPOSN:=LPOSN2;
 LPOSN2:=TEM
 $);

let GETPOSINT(PROMPT,QQSTR,ANYOK) = valof
 $( static $( POSINT = NIL; INT = "AN INTEGER GREATER THAN ZERO";
              AINT = "AN INTEGER GREATER THAN ZERO, OR THE WORD 'ANY'" $);
 TRYPROMPT:
 unless CONDPROMPT(PROMPT,(ANYOK -> AINT,INT),0,QQSTR,(ANYOK -> NSTV,NTV)) DO
  resultis -1;
 POSINT:=LITEMS![LPOSN+1];
 if NEXTIS(STRTYPE) DO
  test STRCONTAIN(STROFNUM(POSINT),"ANY") then
   $( LOPITEM(); resultis PLUSINF $)
  OR
   $(
   OUTSNUM(POSINT);
   OUTS(" ISN'T AN EXPECTED RESPONSE HERE*C*L");
   FLUSHLINE();
   goto TRYPROMPT
   $);
 if POSINT>0 do $( LOPITEM(); resultis POSINT $);
 OUTS("THIS QUANTITY SHOULD be GREATER THAN ZERO*C*L");
 FLUSHLINE();
 goto TRYPROMPT
 $);

let GETNONNEGINT(PROMPT,QQSTR,ANYOK) = valof
 $( static $( NONNEGINT = NIL; INT = "A NON-NEGATIVE INTEGER";
              AINT = "A NON-NEGATIVE INTEGER, OR THE WORD 'ANY'" $);
 TRYPROMPT:
 unless CONDPROMPT(PROMPT,(ANYOK -> AINT,INT),0,QQSTR,(ANYOK -> NSTV,NTV)) DO
  resultis -1;
 NONNEGINT:=LITEMS![LPOSN+1];
 if NEXTIS(STRTYPE) DO
  test STRCONTAIN(STROFNUM(NONNEGINT),"ANY") then
   $( LOPITEM(); resultis PLUSINF $)
  OR
   $(
   OUTSNUM(NONNEGINT);
   OUTS(" ISN'T AN EXPECTED RESPONSE HERE*C*L");
   FLUSHLINE();
   goto TRYPROMPT
   $);
 if NONNEGINT GE 0 do $( LOPITEM(); resultis NONNEGINT $);
 OUTS("THIS QUANTITY SHOULD NOT be NEGATIVE*C*L");
 FLUSHLINE();
 goto TRYPROMPT
 $);

let BADNAME(RESERVEDNAMES,ERRSTR) = valof
 $( static $( NAMESTR = NIL; NRES = NIL $);
 NAMESTR:=STROFNUM(LITEMS![LPOSN+1]);
 NRES:=RESERVEDNAMES!0+1;
 while NRES>1 DO
  $(
  NRES-:=1;
  unless STREQUAL(NAMESTR,RESERVEDNAMES!NRES) do loop;
  OUTS(ERRSTR);
  NEWLINE(1);
  resultis TRUE
  $);
 resultis FALSE
 $);
GET "LSTFNS.BCL"
GET "SEGFNS.BCL"
GET "MAKPAT.BCL"
GET "GMATCH.BCL"
GET "PATSIN.BCL"

LET PUTSTRUC() BE
 $( STATIC $( NISB = NIL $);
 OUTPUT:=OUTFILE;
 IF STRUCNUMBER>0 DO $( OUTCH(46); OUTNOS(STRUCNUMBER) $);
 FOR I=1 TO GSTOP DO
  $(
  NISB:=NUMISBS!I<<1;
  IF ARTYPE!I=2 DO OUTCH([125+48]REM 128);
  WHILE NISB>0 DO $( NISB-:=1; OUTCH([I+48]REM 128) $);
  FOR J=CTSTART!I TO CTSTOP!I DO OUTCH([[CTABLE!J]+48]REM 128);
  OUTCH(48)
  $);
 OUTCH(47);
 OUTPUT:=TTY
 $);

let FETCHSTRUC() = valof
 $( static $( CTPTR = NIL; NBR = NIL; NDIX = NIL; ONBR = NIL;
              NDOT = NIL; NISB = NIL; NH = NIL; SKIP = NIL $);
 STRUCNUMBER:=0;
 INPUT:=INFILE;
 NEXTSTRUC:
 SKIP:=FALSE;
 NBR:=[INCH()+80]REM 128;
 if NBR=127 do $( INPUT:=INSOURCE; resultis FALSE $);
 if NBR=126 do $( STRUCNUMBER:=INNO(); INCH(); NBR:=[INCH()+80]REM 128 $);
 CTPTR:=1;
 NDIX:=0;
 while NBR NE 127 DO
  $(
  NDIX+:=1;
  CTSTART!NDIX:=CTPTR;
  ARTYPE!NDIX:=1;
  ONBR:=0;
  NISB:=0;
  NDOT:=0;
  UNTIL NBR=0 DO
   $(
   test NBR=NDIX then NISB+:=1
   or
   test NBR=125 then ARTYPE!NDIX:=2
   OR
    $(
    if NBR=ONBR do NDOT+:=1;
    ONBR:=NBR;
    CTABLE!CTPTR:=NBR;
    CTPTR+:=1
    $);
   NBR:=[INCH()+80]REM 128
   $);
  CTSTOP!NDIX:=CTPTR-1;
  NH:=TYPEVALENCE![ATTYPE!NDIX]-CTPTR+CTSTART!NDIX-NISB;
  if NH<0 do SKIP:=TRUE;
  NUMHS!NDIX:=NH;
  NUMISBS!NDIX:=NISB>>1;
  DOTS!NDIX:=NDOT;
  NBR:=[INCH()+80]REM 128
  $);
 if SKIP do $( OUTCHP('?'); goto NEXTSTRUC $);
 INPUT:=INSOURCE;
 resultis TRUE
 $);
$LIST
let PROCESS() be $(proc
 
  manifest $( TESTN = 1; SETT = 2; SETF = 3; RET = 0 $);
  static $( TAG = vec 120; TV = vec 120; FV = vec 120; OP = vec 120 $);
  static $( ORSNUM = NIL; ANDSNUM = NIL; NOTSNUM = NIL $);
  static $( MASK = NIL; ACT = NIL; NUMOK = NIL $);
  static $( OIN = NIL; QQSTR="XMN-HELP" $);
  static $( STATUSREC = NIL; SPTR = NIL; STEMP = NIL; RSTART = NIL; RSTOP = NIL;
            DEPTH = NIL $);


LET DRAWMAIN() BE
 $( STATIC $( INNAME = NIL; NAMES2 = VEC 500; ICON2 = VEC 300 $);
 STATIC $( IC1 = NIL; J = NIL; MAX = NIL; INJ = NIL; 
           NUMAT = NIL; NCHAR = NIL; I = NIL; IDUM = NIL $);
 /* First, want to build up the table NAMES2 containing for each atom
  the number of characters in its name and those characters.
*/

 I:=0;
 WHILE I<GSTOP DO
  $(NAMES
  I+:=1;

  INNAME:=ATTYPE!I;
  INNAME:=TYPENAME!INNAME;

  
  IDUM:=1+([I-1]<<2);
  UNPACKSTRING(INNAME,NAMES2+IDUM)
  $)NAMES
 
/* Output structure number. */

 OUTS("*C*L#"); OUTNOL(STRUCNUMBER)


 /* Now we must build the array ICON2. Of course its not actually 
  documented in the original code so guessing a bit here!

  Assuming treating ICON2 as an N*6 array.

 */

 for I=1 to 300 do ICON2!I:=0;
 for I=1 to GSTOP do $(fill
  J:=0;
  for IC1= CTSTART!I to CTSTOP!I do $(nbrs
     J+:=1;
     ICON2!(J+(I-1)*6):=CTABLE!IC1
   $)nbrs
  $)fill;

 NUMAT:=GSTOP

/* Do the Drawing, if many atoms in substructure then call DRAW,
 if just one atom, find its name in NAMES2 and spell out characters there.
*/

 TEST NUMAT>1 THEN DRAW(ICON2,NUMAT,NAMES2)
 OR
  $(
  MAX:=NAMES2!1+1;
  I:=1;
  WHILE I<MAX DO $( I+:=1;  OUTCH(NAMES2!I); $);
  NEWLINE(1)
  $);
 NEWLINE(1)

$)



LET LITNUMTRANS(STRNUM) = VALOF
 $( STATIC $( FIRSTCHAR = NIL; INCORRECT = NIL; NUMBER = NIL $);

 LET EACHCHAR(CHAR) BE
  TEST FIRSTCHAR THEN
   $(
   FIRSTCHAR:=FALSE;
   IF CHAR NE '#' DO INCORRECT:=TRUE
   $)
  OR
   TEST [CHAR GE '0'] BITAND [CHAR LE '9'] THEN NUMBER:=NUMBER*10+CHAR-'0'
   OR INCORRECT:=TRUE;

 FIRSTCHAR:=TRUE;
 INCORRECT:=FALSE;
 NUMBER:=0;
 MAPSTR(STROFNUM(STRNUM),EACHCHAR);
 RESULTIS (INCORRECT -> -1,NUMBER)
 $);

LET RANGESUBST(GIVEN,USED,LITNUMFLAG) = VALOF
 $(
 OUTS((LITNUMFLAG -> "I'LL USE #","I'LL USE "));
 OUTNOS(USED);
 OUTS((LITNUMFLAG -> "INSTEAD OF #","INSTEAD OF "));
 OUTNOL(GIVEN);
 RESULTIS USED
 $);

LET FORCEINRANGE(STRUCPOS,LITNUMFLAG) = VALOF
 $( STATIC $( RANGEMIN = NIL; RANGEMAX = NIL $);
 RANGEMIN:=1; RANGEMAX:=NSTRUCS;
 unless LITNUMFLAG do RANGEMAX:=NUMOK
 IF STRUCPOS<RANGEMIN DO RESULTIS RANGESUBST(STRUCPOS,RANGEMIN,LITNUMFLAG);
 IF STRUCPOS>RANGEMAX DO RESULTIS RANGESUBST(STRUCPOS,RANGEMAX,LITNUMFLAG);
 RESULTIS STRUCPOS 
 $);






LET STRUCSPECREADER(PROMPT,QQSTR) = VALOF
 $( STATIC $( STRUCNUM = NIL; STRUCNAME = NIL; STRUCTYPE = NIL; LOWNUM = NIL;
              HIGHNUM = NIL; TEMP = NIL; POSMINMAXS = NIL;
              LITMINMAXS = NIL 
             $);

 STATIC $( QTBL = [TABLE 8,
     "PLEASE TYPE ONE OR MORE ENTRIES IN ANY OF THE FOLLOWING FORMS:",
     "AN INTEGER N, INDICATING THE NTH STRUCTURE IN YOUR CURRENT LIST",
     "OR: A PAIR OF INTEGERS IN PARENTHESES, E.G. (1 10); (M N) INDICATES A",
     "    RANGE OF THE MTH THROUGH THE NTH STRUCTURES IN YOUR CURRENT LIST",
     "OR: A # FOLLOWED BY AN INTEGER (E.G. #3) INDICATING THE STRUCTURE WHICH",
     "    IS 'ATTACHED' TO THE INDEX N (THIS INDEX IS PRINTED IN DRAWINGS)",
     "OR: A PAIR (#M #N) INDICATING A THE RANGE OF STRUCTURES ASSOCIATED WITH",
     "    INDICES M THROUGH N" ] $);
 POSMINMAXS:=@NULL;
 LITMINMAXS:=@NULL;


TRYPROMPT:
 UNLESS CONDPROMPT(PROMPT,0,QTBL,QQSTR,[TABLE 3,NUMTYPE,STRTYPE,LPARTYPE]) DO
  RESULTIS LIST(POSMINMAXS,LITMINMAXS);
 SWITCHON LITEMS!LPOSN INTO
  $(
  CASE NUMTYPE:
   STRUCNUM:=FORCEINRANGE(LOPITEM(),FALSE);
   POSMINMAXS:=CONS(CONS(STRUCNUM,STRUCNUM),POSMINMAXS);
   GOTO ANYMORE;
   ENDCASE;
 CASE STRTYPE:
   STRUCNAME:=LITEMS![LPOSN+1];
   STRUCNUM:=LITNUMTRANS(STRUCNAME);
   TEST STRUCNUM>0 THEN
    $(
    LOPITEM();
    STRUCNUM:=FORCEINRANGE(STRUCNUM,TRUE);
    LITMINMAXS:=CONS(CONS(STRUCNUM,STRUCNUM),LITMINMAXS);
    GOTO ANYMORE
    $)
   OR
    $(
     OUTS("I'M EXPECTING AN INTEGER, OR RANGE OF INTEGERS ETC.*C*L")
     FLUSHLINE();
     GOTO TRYPROMPT
     $);
   ENDCASE;
  CASE LPARTYPE:
   LOPITEM();
   SWITCHON LITEMS!LPOSN INTO
    $(
    CASE NUMTYPE:
     LOWNUM:=LITEMS![LPOSN+1];
     IF LOWNUM>NSTRUCS DO GOTO INCRANGE;
     LOPITEM();
     LOWNUM:=FORCEINRANGE(LOWNUM,FALSE);
     UNLESS NEXTIS(NUMTYPE) DO GOTO INCRANGE;
     HIGHNUM:=LITEMS![LPOSN+1];
     IF HIGHNUM<LOWNUM DO GOTO INCRANGE;
     LOPITEM();
     HIGHNUM:=FORCEINRANGE(HIGHNUM,FALSE);
     IF NEXTIS(RPARTYPE) DO
      $(
      LOPITEM();
      POSMINMAXS:=CONS(CONS(LOWNUM,HIGHNUM),POSMINMAXS);
      GOTO ANYMORE
      $)
     ENDCASE;
    CASE STRTYPE:
     LOWNUM:=LITNUMTRANS(LITEMS![LPOSN+1]);
     IF LOWNUM<0 DO GOTO INCRANGE;
     IF LOWNUM>NSTRUCS DO GOTO INCRANGE;
     LOPITEM();
     LOWNUM:=FORCEINRANGE(LOWNUM,TRUE);
     UNLESS NEXTIS(STRTYPE) DO GOTO INCRANGE;
     HIGHNUM:=LITNUMTRANS(LITEMS![LPOSN+1]);
     IF HIGHNUM<0 DO GOTO INCRANGE;
     IF HIGHNUM<LOWNUM DO GOTO INCRANGE;
     LOPITEM();
     HIGHNUM:=FORCEINRANGE(HIGHNUM,TRUE);
     IF NEXTIS(RPARTYPE) DO
      $(
      LOPITEM();
      LITMINMAXS:=CONS(CONS(LOWNUM,HIGHNUM),LITMINMAXS);
      GOTO ANYMORE
      $)
    $)
  $);
 INCRANGE:
 OUTS("INCORRECT OR INCOMPLETE RANGE - TYPE ? FOR HELP*C*L");
 FLUSHLINE();
 GOTO TRYPROMPT;
 ANYMORE:
 UNLESS NEXTIS(EOLTYPE) DO GOTO TRYPROMPT;
 RESULTIS LIST(POSMINMAXS,LITMINMAXS)
 $);



LET CLEANSSLIST(SSLIST) BE
$(
 MAPC(CAR(SSLIST),UNCONS);
 SSLIST:=UNCONS(SSLIST);
 UNLIST(CAR(SSLIST));
 UNCONS(SSLIST)
 $);






let DRAWSTRUCS() be $(drwstrs
 static $( APPROPNO = NIL; COUNT = NIL; DRAWN = NIL;
	TEMP = NIL; INSOMERANGE = NIL; SSLIST = NIL; BIT = NIL $)


  let MINMAXTEST(MINMAX) = valof
    $(
    unless APPROPNO LE CDR(MINMAX) do resultis FALSE
    resultis APPROPNO GE CAR(MINMAX)
    $)

  SSLIST:=@NULL
  SSLIST:=STRUCSPECREADER("STRUCTURES TO BE DRAWN: ","HELP")
  if SSLIST=@NULL then return
  INFILE:=FINDFILE("DSK",STRFILENAME(),CGEXT);
  INPUT:=INFILE;
  INNO();
  INNO();
  for ND=1 to GSTOP do INS(); 
  INSOURCE:=FINDFILE("DSK",SC1FILENAME(),CGEXT);
  INPUT:=INSOURCE;
  COUNT:=0; DRAWN:=0
  for N=1 to NSTRUCS do $(strucs
    STRUCNUMBER:=INNO();
    TEMP:=INNO();
    INSET(MASK);
    FETCHSTRUC();
    BIT:=(TEMP REM 2) = 1;
    unless BIT do loop
    COUNT+:=1
    APPROPNO:=COUNT
    if SOME(CAR(SSLIST),MINMAXTEST) NE @NULL then $( DRAWMAIN(); DRAWN+:=1; loop $)
    APPROPNO:=STRUCNUMBER
    if SOME(CAR(CDR(SSLIST)),MINMAXTEST) NE @NULL then $( DRAWMAIN(); DRAWN+:=1; loop $)

    $)strucs
  ENDREAD(INSOURCE);
  ENDREAD(INFILE)
  INPUT:=TTY
  CLEANSSLIST(SSLIST)
  SSLIST:=@NULL
  if DRAWN=0 then OUTS("*C*LEMPTY STRUCTURE RANGE*C*L")

$)drwstrs



let SELECT() = valof $(sct
 /* This code reads in a logical expression and converts
     it into a tabular form for interpretation. The algorithm
     is a standard one:
     D. Gries "Compiler Construction for Digital Computers"
         section 13.6.
     The code looks slightly convoluted for I have just taken
     Gries's code (in an ALGOL dialect) which used call by
     reference and substituted into BCPL (where have only call
     by value), so where call by reference is really needed I
     pass addresses and use indirection.
   
        The logical expressions are to be in the form
     EXPRESSION
       which is TERM {OR TERM}
         where a TERM is FACTOR {AND FACTOR}
           and a FACTOR is and <IDENTIFIER> | NOT <IDENTIFIER> |
                                (EXPRESSION)
   */

  /* SELECT returns true unless "DEPTH" exceeds 5 on entry, this
     provides a way of preventing user from nesting logical selection
     terms too deeply.
  */

  static $( NQ = NIL; NXTSYMB = NIL $);
  static $( BREAKOUT = NIL $);
  
   let ERROR(STR) be $(err
     OUTS(STR);
     OUTS("*C*LABANDONED*C*L");
     FLUSHLINE();
     JUMP(BREAKOUT)
     $)err

  let FILLIN(K) be $(fill
   static $( SAVE = NIL; I = NIL $);
   $(rpt
     SAVE:=ABS K;
     I:=((K > 0)->TV,FV);
     K:=I!SAVE;
     I!SAVE:=NQ
     $)rpt repeatuntil (K = 0);
   $)fill;

  let MERGE(K1,K2) be $(mrg
   static $( K = NIL; I = NIL $);
   /* (note, given addresses as arguments.) */
   /* K1 and K2 point to variables that hold beginings of two */
   /* lists of numbers that are to be merged. */
   /* if the original list is empty, just move new list in. */
  test !K1 = 0 then !K1:=!K2
   or $(append
     /* have to find the end of the K1 list. */
     K:=!K1;
     $(rpt
      I:=((K > 0)->TV,FV);
      K:=ABS K;
      test I!K = 0 then break
        or K:=I!K
      $)rpt repeat;
      I!K:=!K2
      $)append
   $)mrg


  let ENTER(OPSYM,VAL,TX,FX) be $(enter
     OP!NQ:=OPSYM;
     TAG!NQ:=VAL;
     TV!NQ:=TX;
     FV!NQ:=FX;
     NQ+:=1
    $)enter

 let E1(TCHAIN,FCHAIN) be $(e1
  let TC=0;
//   OUTS("*C*LLooking for an expression.*C*L");
  /* this routine to deal with expressions of form T | T OR T */

  !TCHAIN:=0; !FCHAIN:=0;
   $(rd
    T1(@TC,FCHAIN);
    MERGE(TCHAIN,@TC);
    /* if at end of input its OK and can stop. */
    /* if at a closing parentheses then maybe have finished a subexpression. */


    if NEXTIS(EOLTYPE) | NEXTIS(PSEOLTYPE) | NEXTIS(RPARTYPE)  do break;

    /* otherwise, must have "OR" as next input symbol. */

    unless NEXTIS(STRTYPE) do ERROR("Expected a string.");
    NXTSYMB:=LOPITEM();
    unless NXTSYMB=ORSNUM do ERROR("Expected an OR");

    /* enter in status record so that may regenerate expressions. */
    STEMP+:=1; STATUSREC!STEMP:=ORSNUM;

    /* Fill in all false branches so far to go to next item. */

    FILLIN(!FCHAIN);
    !FCHAIN:=0
    $)rd repeat;
   $)e1
 and T1(TCHAIN,FCHAIN) be $(t1
   let FC=0;
//     OUTS("*C*LLooking for a term.");
    /* Here, we are processing a term of the form F | F AND F */

    !TCHAIN:=0; !FCHAIN:=0;
    $(rpt
      /* Call F1 to process the (first) factor */
      F1(TCHAIN,@FC);

      /* Add new false branches to false chain. */

      MERGE(FCHAIN,@FC);
  
      /* Now need to now if there is another factor being ANDed in. */

      unless NEXTIS(STRTYPE) & LITEMS!(LPOSN+1)=ANDSNUM do break;
      
      /* As there is another AND, fill in branches to TRUE. */

      FILLIN(!TCHAIN);
      !TCHAIN:=0;
     
      /* enter into record */
      STEMP+:=1; STATUSREC!STEMP:=ANDSNUM;

      /* remove the "AND" from the input. */

      LOPITEM()
     
      $)rpt repeat;
   $)t1
 and F1(TCHAIN,FCHAIN) be $(f1
//    OUTS("*C*LLooking for a factor.");
   test NEXTIS(LPARTYPE) then $(parens
      LOPITEM();
      /* in STATUSREC, encode the Left Parenthesis by a -1. */
      STEMP+:=1; STATUSREC!STEMP:=-1;

      E1(TCHAIN,FCHAIN);
      test NEXTIS(RPARTYPE) then LOPITEM() or ERROR("No closing parenthesis.");

      /* in STATUSREC, encode Right Parentheses by a -2. */

      STEMP+:=1; STATUSREC!STEMP:=-2 

      $)parens 
   or
   test (NEXTIS(STRTYPE) & (LITEMS!(LPOSN+1)=NOTSNUM))
     then $(negate
       static $( K = NIL $);
//       OUTS("*C*LComplementing factor.");
       LOPITEM();
       /* enter in STATUSREC. */

       STEMP+:=1; STATUSREC!STEMP:=NOTSNUM;


       F1(TCHAIN,FCHAIN);
       /* Switch the chains for what was once TRUE is now FALSE. */
       K:=!TCHAIN;
       !TCHAIN:=!FCHAIN;
       !FCHAIN:=K
       $)negate
   or
   test NEXTIS(STRTYPE) 
    then $(key
     static $( KEY = NIL $);
     /* should be at an identifier. */
     KEY:=LOPITEM();
     /* Should be one of the defined terms. */
     unless (KEY GE FEATURENAMES!1) & (KEY LE FEATURENAMES!NUMPAT) do
        $( NEWLINE(1); OUTSNUM(KEY);
	ERROR(" isn't one of your defined selection features.")
        $);

     /* enter in STATUSREC */
     STEMP+:=1; STATUSREC!STEMP:=KEY;

     /* Now convert to index number of this key in the set of features. */

     KEY:= valof $( for N=1 to NUMPAT do if KEY=FEATURENAMES!N then 
           resultis N
           $);
     
     !TCHAIN:=NQ;
     !FCHAIN:=-NQ;
     ENTER(TESTN,KEY,0,0)
     $)key
   or ERROR("can't identify factor.")
   $)f1
 and Z1() be $(z1
  let FCHAIN,TCHAIN=0,0;
    NQ:=1;
    ENTER(SETT,0,0,0);
    E1(@TCHAIN,@FCHAIN);
    unless NEXTIS(EOLTYPE) | NEXTIS(PSEOLTYPE) do
       ERROR(
       "Selection request improperly terminated (maybe too many parentheses)");

    FILLIN(FCHAIN);
    ENTER(SETF,0,0,0);
    FILLIN(TCHAIN);
    ENTER(RET,0,0,0);
    NQ-:=1
   $)z1

  if DEPTH GE 5 then $(toodeep
     OUTS("You are nesting selection requests too deeply for this");
     NEWLINE(); OUTS("program to manage.*C*L");
     FLUSHLINE();
     resultis FALSE
     $)toodeep

  BREAKOUT:=LABEL(REQLOOP);

REQLOOP:
CONDPROMPT("Desired features>",
	    "Some logical combination of featurenames e.g. A AND (B OR C)",
             0,QQSTR,SLTV);
  STEMP:=SPTR;
  Z1();
  DEPTH+:=1;
  RSTART!DEPTH:=SPTR+1;
  RSTOP!DEPTH:=STEMP;
  SPTR:=STEMP
$)sct


let EVALSELECT() be $(eval
  static $( OIN = NIL $);

  let TESTMASK() = valof $(tm

  static $( LN = NIL; RES = NIL $);
  LN:=1; RES:=TRUE;
  $(rpt
  switchon OP!LN into $(sw
    case SETT: RES:=TRUE; LN+:=1; endcase;
    case SETF: RES:=FALSE; LN+:=1; endcase;
    case RET: resultis RES; endcase;
    case TESTN: test TESTELEM(TAG!LN,MASK) then LN:=TV!LN
                      or LN:=FV!LN; endcase;
    default:
    $)sw
  $)rpt repeat;
  $)tm

  /* Read file of structure tags etc, testing for those
     that satisfy the new selection request. Create a new
     file for the results.
  */
  OOUT:=OUTPUT;
   OUTPUT:=CREATEFILE("DSK",SC2FILENAME(),CGEXT);
  OIN:=INPUT;
  INPUT:=FINDFILE("DSK",SC1FILENAME(),CGEXT);
  NUMOK:=0;
  for N=1 to NSTRUCS do $(strucs
    static $( BIT = NIL;  TEMP = NIL $);
    STRUCNUMBER:=INNO(); TEMP:=INNO(); INSET(MASK);
    
    /* The low order bit of TEMP indicates if this structure survived
       previous selection requests. If this bit is zero then the
       structure has already been eliminated and need not make further
       checks. */

    BIT:=TEMP REM 2; 
    TEMP:=TEMP << 1;
    
    unless BIT = 0 do 
       test TESTMASK() then NUMOK+:=1 or BIT:=0;
 
    TEMP+:=BIT;
    
    OUTNOS(STRUCNUMBER); OUTNOS(TEMP); OUTSET(MASK);
    NEWLINE(1)
    $)strucs
  ENDWRITE(OUTPUT);
  ENDREAD(INPUT);
  INPUT:=OIN;
  OUTPUT:=OOUT;
  INTERRUPTABLE(FALSE);
  FILEREPLACE(SC1FILENAME(),CGEXT,SC2FILENAME(),CGEXT);
  INTERRUPTABLE(TRUE);
  NEWLINE(1);
  OUTNOS(NUMOK);
  OUTS("structures.*C*L")
$)eval



let LINDEX() be $(lndx
  static $( COUNT = NIL $);
  OIN:=INPUT;
  INPUT:=FINDFILE("DSK",SC1FILENAME(),CGEXT);
  OUTNOS(NUMOK);
  OUTS("structures currently selected.*C*LIndex numbers are:*C*L");
  COUNT:=0;
  for N=1 to NSTRUCS do $(strucs
    static $( BIT = NIL; TEMP = NIL $);
    STRUCNUMBER:=INNO(); TEMP:=INNO(); INSET(MASK);
    BIT:=TEMP REM 2;
    unless BIT=0 do $(ok
       OUTNON(STRUCNUMBER,5); COUNT+:=1;
       if COUNT=12 then $( NEWLINE(1); COUNT:=0 $)
       $)ok;
    $)strucs;
  ENDREAD(INPUT);
  INPUT:=OIN;
  NEWLINE(1)
  $)lndx

let LTERMS() be $(ltrms
 static $( TAG = NIL $);
 TAG:=FALSE;
 for I=1 to NUMPAT do FCOUNTS!I:=0;
 OIN:=INPUT;
 INPUT:=FINDFILE("DSK",SC1FILENAME(),CGEXT);
 for N=1 to NSTRUCS do $(strucs
   static $( TEMP = NIL; BIT = NIL $);
   STRUCNUMBER:=INNO(); TEMP:=INNO(); INSET(MASK);
   BIT:=(TEMP REM 2) = 1;
   if BIT then  
      for T=1 to NUMPAT do if TESTELEM(T,MASK) then FCOUNTS!T+:=1;
  $)strucs;
 ENDREAD(INPUT);
 INPUT:=OIN;
 for I=1 to NUMPAT do $(IL
  unless (FCOUNTS!I = 0) | (FCOUNTS!I GE NSTRUCS) do $(lst
    unless TAG do $(HD
        TAG:=TRUE;
        OUTS("Discriminating features are:*C*L");
        OUTS("Frequency  feature*C*L")
        $)HD
    OUTNON(FCOUNTS!I,8);SPACES(3);
    OUTSNUM(FEATURENAMES!I); NEWLINE(1)
    $)lst
  $)IL;
 unless TAG do $( OUTS("*C*LNo discriminating features remain.*C*L");
                  return $);
 NEWLINE(1)
 $)ltrms



let RESTART() be $(rstrt
  DEPTH:=0;
  SPTR:=0;
  NUMOK:=NSTRUCS;
  OOUT:=OUTPUT;
  OUTPUT:=CREATEFILE("DSK",SC2FILENAME(),CGEXT);
  OIN:=INPUT;
  INPUT:=FINDFILE("DSK",SC1FILENAME(),CGEXT);
  for N=1 to NSTRUCS do $(strucs
    OUTNOS(INNO()); INNO(); OUTNOS(1);
    INSET(MASK);
    OUTSET(MASK);
    NEWLINE(1)
    $)strucs
  ENDREAD(INPUT); ENDWRITE(OUTPUT);
  INTERRUPTABLE(FALSE);
  FILEREPLACE(SC1FILENAME(),CGEXT,SC2FILENAME(),CGEXT);
  INTERRUPTABLE(TRUE);
  INPUT:=OIN;
  OUTPUT:=OOUT;
  OUTNOS(NUMOK); 
  OUTS("structures.*C*L") 

 $)rstrt

let RESET() be $(rset
  if DEPTH = 0 then $(top
   OUTS("You are already at the top and can not RESET anymore.*C*L");
   return
   $)top
  DEPTH-:=1;
  SPTR:=RSTOP!DEPTH;
  NUMOK:=0;
  OIN:=INPUT;
  OOUT:=OUTPUT;
  INPUT:=FINDFILE("DSK",SC1FILENAME(),CGEXT);
  OUTPUT:=CREATEFILE("DSK",SC2FILENAME(),CGEXT);
  for N=1 to NSTRUCS do $(strucs
   static $( TEMP = NIL $);
   OUTNOS(INNO());
   TEMP:=INNO() >> 1;
   unless (TEMP REM 2) = 0 do NUMOK+:=1;
   OUTNOS(TEMP);
   INSET(MASK);
   OUTSET(MASK);
   NEWLINE(1)
   $)strucs;
  ENDREAD(INPUT);
  ENDWRITE(OUTPUT);
  INTERRUPTABLE(FALSE);
  FILEREPLACE(SC1FILENAME(),CGEXT,SC2FILENAME(),CGEXT);
  INTERRUPTABLE(TRUE);
  INPUT:=OIN;
  OUTPUT:=OOUT;
  OUTNOS(NUMOK);
  OUTS("structures.*C*L")
$)rset


let RSTATUS() be $(rptsts
  let OUTSELECTOR(R1,R2) be $(outs
   for R=R1 to R2 do $(rl
     test STATUSREC!R GR 0 then OUTSNUM(STATUSREC!R)
     or 
     test STATUSREC!R = -1 then OUTS("(")
     or OUTS(")");
     if R LS R2 then SPACES(1)
     $)rl
   $)outs

  OUTNOS(NUMOK); OUTS("structures.*C*L");
  if DEPTH=0 then return;
  OUTS("*C*LCurrent selection criterion is :");

  for D=1 to DEPTH do $(dl
    OUTS("*C*L(");
    OUTSELECTOR(RSTART!D,RSTOP!D);
    OUTS(")");
    if D LS DEPTH then OUTS(" AND")
    $)dl
  NEWLINE(1)
  $)rptsts



let CHECKSTEREO() = valof $(
 unless FILEEXISTS(STIFILENAME(),CGEXT) do resultis TRUE
 OUTS("*C*LIf I prune your structure list now, I will have to throw away*C*L")
 OUTS("the data defining stereoisomers.*C*L")
 unless YESNO("Do you want me to continue anyway?","its up to you","NO")
	do resultis FALSE
 while DELETEFILE(STIFILENAME(),CGEXT) do;
 resultis TRUE
 $)



let MODFILES(LVAL) be $(mdfl
 /* LV indicates if structures in current set are to be kept
    (REPLACE  command) or eliminated (REMOVE command).

    Take two passes through the file rather than have two output
    scratch files around.

  */

  static $( BIT = NIL; TEMP = NIL; MINSNUM = NIL; MAXSNUM = NIL; COUNT = NIL $);

  unless CHECKSTEREO() do return
  INFILE:=FINDFILE("DSK",STRFILENAME(),CGEXT);
  OUTFILE:=CREATEFILE("DSK",SC3FILENAME(),CGEXT);

  /* Copy header info in structures file to the new scratch file. */

  

  INPUT:=INFILE;
  OUTPUT:=OUTFILE;
  OUTNOS(INNO());
  OUTNOS(INNO());
  for ND=1 to GSTOP do $( OUTS(INS()); SPACES(1) $);

  MINSNUM:=PLUSINF; MAXSNUM:=0; COUNT:=0;

  /* Now use info in scratch file SC1 to find which structures
     should be copied. */

  INSOURCE:=FINDFILE("DSK",SC1FILENAME(),CGEXT);
  INPUT:=INSOURCE;
  
  for N=1 to NSTRUCS do $(strucs
   STRUCNUMBER:=INNO();
   TEMP:=INNO();
   INSET(MASK);
   FETCHSTRUC();
   BIT:=(TEMP REM 2) = 1;
   if BIT=LVAL then $(put
        MINSNUM:=(MINSNUM<STRUCNUMBER->MINSNUM,STRUCNUMBER);
        MAXSNUM:=(MAXSNUM>STRUCNUMBER->MAXSNUM,STRUCNUMBER);
        COUNT+:=1;
        PUTSTRUC()
        $)put
   $)strucs
   ENDREAD(INSOURCE);
   ENDREAD(INFILE);
   OUTPUT:=OUTFILE;
   OUTCH(47);
   ENDWRITE(OUTFILE);

   OUTPUT:=CREATEFILE("DSK",SC2FILENAME(),CGEXT);
   INPUT:=FINDFILE("DSK",TOPFILENAME(),CGEXT);
   COPYSEGSTO(CHUNKSEP,SSHEADSTR,TRUE);
   OUTNOL(COUNT); OUTNOS(MINSNUM); OUTNOL(MAXSNUM); OUTNOS(U)
   for I=1 to NTYPES do
    if [TYPENUM!I]>0 do $( OUTS(TYPENAME!I); SPACES(1); OUTNOS(TYPENUM!I) $);
   NEWLINE(1);
   SKIPSEG(CHUNKSEP);
   OUTCH(CHUNKSEP);
   COPYTOEND();
   ENDREAD(INPUT);
   ENDWRITE(OUTPUT);
   INTERRUPTABLE(FALSE);
   FILEREPLACE(STRFILENAME(),CGEXT,SC3FILENAME(),CGEXT);
   FILEREPLACE(TOPFILENAME(),CGEXT,SC2FILENAME(),CGEXT);
   INTERRUPTABLE(TRUE);
 
   /* Now must make the modified version of SC1 file. */
   INPUT:=FINDFILE("DSK",SC1FILENAME(),CGEXT);
   OUTPUT:=CREATEFILE("DSK",SC2FILENAME(),CGEXT);
   for N=1 to NSTRUCS do $(strucs
      STRUCNUMBER:=INNO();
      TEMP:=INNO();
      INSET(MASK);
      BIT:=(TEMP REM 2) = 1;
      if (BIT = LVAL) then $(put
        OUTNOS(STRUCNUMBER); OUTNOS(1); OUTSET(MASK);
        NEWLINE(1)
        $)put
      $)strucs
   ENDREAD(INPUT);
   ENDWRITE(OUTPUT);
   INTERRUPTABLE(FALSE);
   FILEREPLACE(SC1FILENAME(),CGEXT,SC2FILENAME(),CGEXT);
   INTERRUPTABLE(TRUE);
   INPUT:=TTY;
   OUTPUT:=TTY
$)mdfl
  

let REMOVE() be $(rmv
  if NUMOK=NSTRUCS then $(NO
    OUTS("But that would leave no structures!*C*L");
    return
    $)NO;
  MODFILES(FALSE);
  NSTRUCS:=NSTRUCS-NUMOK;
  NUMOK:=NSTRUCS;
  SPTR:=0;
  DEPTH:=0
$)rmv


let REPLACE() be $(rpl
  if NUMOK=NSTRUCS then $(null
    OUTS("No changes needed.*C*L");
    return
    $)null;
  MODFILES(TRUE);
  NSTRUCS:=NUMOK;
  SPTR:=0;
  DEPTH:=0
$)rpl

  ANDSNUM:=NUMOFSTR("AND");
  ORSNUM:=NUMOFSTR("OR");
  NOTSNUM:=NUMOFSTR("NOT");
  MASK:=MAKESET();
  DEPTH:=0;
  STATUSREC:=NEWVEC(150); SPTR:=0;
  RSTART:=NEWVEC(5); RSTOP:=NEWVEC(5);

  NUMOK:=NSTRUCS;
  $(rpt
  ACT:=PROMPTSELECT("->",
	    "DONE DRAW INDEX REMOVE REPLACE RESET RESTART SELECT STATUS TERMS",0,
                    QQSTR,[TABLE 10,"DONE",1,"INDEX",2,"SELECT",3,"TERMS",4,
                                    "RESET",5,"RESTART",6,"STATUS",7,
                                    "REMOVE",8,"REPLACE",9,"DRAW",10, 0],
                    TRUE);
  switchon ACT into $(sw
   case 1: return; endcase;
   case 2: LINDEX(); endcase;
   case 3: if SELECT() then EVALSELECT(); endcase;
   case 4: LTERMS(); endcase;
   case 5: RESET(); endcase;
   case 6: RESTART(); endcase;
   case 7: RSTATUS(); endcase;
   case 8: REMOVE(); endcase;
   case 9: REPLACE(); endcase;
   case 10: DRAWSTRUCS(); endcase;
   default:
  $)sw		      
  $)rpt repeat

$)proc

RECINIT();
INFILE:=FINDFILE("DSK",STRFILENAME(),CGEXT);
if FILEEXISTS(SC1FILENAME(),CGEXT) DO
 $( INPUT:=FINDFILE("DSK",SC1FILENAME(),CGEXT);
    READRETURN()
 $)
INSOURCE:=INPUT;
OUTSIF("NUMBER OF ATOM TYPES:"); NTYPES:=INNO();
TYPENAME:=NEWVEC(NTYPES); TYPEVALENCE:=NEWVEC(NTYPES);
TYPENAME!0:="**"; TYPENUM:=NEWVEC(NTYPES);
ATHSTART:=NEWVEC(NTYPES); NATH:=0;
OUTSIF("NAMES AND VALENCES:");

FOR I=1 TO NTYPES DO
 $(
 TYPENUM!I:=0;
 TYPENAME!I:=COPYS(INS());
 TYPEVALENCE!I:=INNO();
 ATHSTART!I:=NATH;
 NATH+:=TYPEVALENCE!I+1
 $);
OUTSIF("NUMBER OF PATTERNS:");NUMPAT:=INNO();
PATNNDS:=NEWVEC(NUMPAT);
PATMINS:=NEWVEC(NUMPAT);
PATMAXS:=NEWVEC(NUMPAT);
OUTSIF("NUMBER OF NODES for EACH PATTERN:"); NNODES:=0;
FOR I=1 TO NUMPAT do $( PATNNDS!I:=INNO(); NNODES+:=PATNNDS!I $);
OUTSIF("NAMES OF FEATURES:")
FEATURENAMES:=NEWVEC(NUMPAT); FCOUNTS:=NEWVEC(NUMPAT);

/* The names of the features are read using Carhart's string-processing
   package so that they may be used later when selecting on keys etc. */

INITLISTS(NEWVEC(1000),1000)
MAKESCAT(NEWVEC(200),200,NEWVEC(400),400);


FOR I=1 TO NUMPAT do $(
  FEATURENAMES!I:=NUMOFSTR(INS());
//  OUTNOS(I); OUTSNUM(FEATURENAMES!I); NEWLINE(1);
  FCOUNTS!I:=0
  $)
PATRECS:=NEWVEC(NUMPAT);
INPUT:=INFILE;
GSTOP:=INNO();
NNODES+:=GSTOP;
ATTYPE:=NEWVEC(NNODES); ATTYPEH:=NEWVEC(NNODES); CTSTART:=NEWVEC(NNODES);
CTSTOP:=NEWVEC(NNODES); DOTS:=NEWVEC(NNODES);
HMIN:=NEWVEC(NNODES); NUMHS:=HMIN; HMAX:=NEWVEC(NNODES-GSTOP)-GSTOP;
LMINS:=NEWVEC(NNODES-GSTOP)-GSTOP; LMAXS:=NEWVEC(NNODES-GSTOP)-GSTOP;
NUMISBS:=NEWVEC(GSTOP);
FOR I=GSTOP+1 TO NNODES do $( LMINS!I:=0; LMAXS!I:=0 $);
ARTYPE:=NEWVEC(NNODES); for I=1 to NNODES do ARTYPE!I:=0;
MAPPEDTO:=NEWVEC(NNODES); for I=1 TO NNODES do MAPPEDTO!I:=0;
U:=INNO();
CTPTR:=1+2*[U+GSTOP-1];
FOR I=1 TO GSTOP DO
 $(
 ATI:=FINDTYPE(INS());
 ATTYPE!I:=ATI;
 ATTYPEH!I:=ATHSTART!ATI;
 TYPENUM!ATI+:=1
 $);
INPUT:=INSOURCE;
PATSTOP:=GSTOP;
CTABLE:=STACK;
READPATS();
CTPTR-:=1;
unless INPUT=TTY DO
 $(
 ENDREAD(INPUT);
 DELETEFILE(SC1FILENAME(),CGEXT);
 INPUT:=TTY
 $);

CTABLE:=STACK;
STACKPTR:=CTPTR+1;

OUTS("*C*LSCANNING THROUGH STRUCTURES.*C*L");
NSTRUCS:=0;
NSETWDSM1:=NUMPAT >> P2WDSZ;
OUTFILE:=CREATEFILE("DSK",SC1FILENAME(),CGEXT);
MATCH:=MAKESET();
while FETCHSTRUC() DO
 $(
 OUTCHP('.');
 NSTRUCS+:=1;
 ZEROSET(MATCH);
 for PAT=1 TO NUMPAT DO
   if GMATCH( PATRECS!PAT,1,GSTART,GSTOP,0,0)
     then $(match
          FCOUNTS!PAT+:=1;
          FLIPELEM(PAT,MATCH)
          $)match;
 OOUT:=OUTPUT; OUTPUT:=OUTFILE;
 OUTNOS(STRUCNUMBER);
 OUTNOS(1);
 OUTSET(MATCH);
 NEWLINE(1);
 OUTPUT:=OOUT;

 $);
ENDREAD(INFILE);
ENDWRITE(OUTFILE);
NEWLINE(1);
TAG:=TRUE;
FOR I=1 TO NUMPAT do $(
  if FCOUNTS!I = 0 do $(ZERO
	if TAG do $(HEADER
		TAG:=FALSE;
		OUTS("*C*LTHE FOLLOWING LIBRARY FEATURES WERE NOT FOUND");
		OUTS(" IN ANY STRUCTURE.*C*L")
		$)HEADER
	OUTSNUM(FEATURENAMES!I);
	NEWLINE(1)
	$)ZERO
  $)
TAG:=TRUE;
FOR I=1 TO NUMPAT do $(
  if FCOUNTS!I = NSTRUCS do $(ALL
	if TAG  do $(HD
		TAG:=FALSE;
		OUTS("*C*LTHE FOLLOWING LIBRARY FEATURES ARE IN ALL STRUCTURES.*C*L")
		$)HD
	OUTSNUM(FEATURENAMES!I);
	NEWLINE(1)
	$)ALL
 $)
TAG:=TRUE;
FOR I=1 TO NUMPAT do $(
 if FCOUNTS!I = 0 then loop;
 if FCOUNTS!I = NSTRUCS then loop;
 if TAG then $(HD1
   TAG:=FALSE;
   OUTS("*C*L#STRUCTURES WITH DISCRIMINATING FEATURES:*C*L")
   $)HD1
OUTNON(FCOUNTS!I,10);
SPACES(4);
OUTSNUM(FEATURENAMES!I);
NEWLINE(1)
$);

/* If no features discriminate amongst structures then return. */
if TAG then EXECUTERETURN()

/* Free a little of the vecspace for re-use. */

FREEVEC(MAPPEDTO);
FREEVEC(NUMISBS);
FREEVEC(LMAXS+GSTOP);
FREEVEC(LMINS+GSTOP);
FREEVEC(HMAX+GSTOP);
FREEVEC(HMIN);
FREEVEC(DOTS);
FREEVEC(CTSTOP);
FREEVEC(CTSTART);
FREEVEC(PATNNDS);

INPUT:=TTY;
if YESNO("Do you want to select structures with combinations of features?",
         "","NO")
  then PROCESS();

EXECUTERETURN()
$);
let START() be
 $(
//  ![#124]:=TOPORSTOP;
 INITIALISEIO(VECSPACE,40000);
 OUTPUT:=TTY;
 INPUT:=TTY;
 DOSTUFF()
 $)
